home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / Class.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1995-05-04  |  9.1 KB  |  276 lines  |  [TEXT/.Ob4]
  1. Syntax10.Scn.Fnt
  2. FoldElems
  3. Syntax10.Scn.Fnt
  4. (*---------------------------------------------------------------------
  5. Extracts class interfaces from a source module (record types with type-bound procedures)
  6. Class.Show *
  7.     shows the interfaces of all record types in the marked source text.
  8. Class.Show modulename.typename
  9.     shows the interface of the specified type.
  10. Class.Show ^
  11.     shows the interface of the specified type. The selection may be
  12.     - a (non-imported) type name in the source text of the declaring module.
  13.     - a combination modulename.typename in any text.
  14. ----------------------------------------------------------------------*)
  15. Syntax10i.Scn.Fnt
  16. StampElems
  17. Alloc
  18. 4 May 95
  19. Syntax10b.Scn.Fnt
  20. Documentation
  21. MODULE Class;    (** HM 26-11-93 / 
  22.     IMPORT
  23.         Oberon, Viewers, Texts, TextFrames, MenuViewers;
  24.     CONST
  25.         StdMenu = "System.Close  System.Copy  System.Grow  Edit.Search  Edit.Store";
  26.         TAB = 9X;  CR = 0DX;
  27.         eot = 0; procedure = 1;  array = 2; record = 3;  pointer = 4;  end = 5; colon = 6;
  28.         lparen = 7;  rparen = 8;  semicolon = 9; eql = 10; arrow = 11; star = 12;
  29.         ident = 13; none = 99;
  30.     TYPE
  31.         Name = ARRAY 64 OF CHAR;
  32.         Class = POINTER TO ClassDesc;
  33.         Method = POINTER TO MethodDesc;
  34.         ClassDesc = RECORD
  35.             name: Name;
  36.             kind: INTEGER;
  37.             beg, end: LONGINT;
  38.             methods: Method;
  39.             link, next: Class
  40.         END;
  41.         MethodDesc = RECORD
  42.             beg, end: LONGINT;
  43.             next: Method
  44.         END;
  45.         ch: CHAR;
  46.         sym, lastSym: INTEGER;
  47.         pos, lastPos: LONGINT;
  48.         B: Texts.Buffer;
  49.         TMod, TOut: Texts.Text;
  50.         R: Texts.Reader;
  51.         W: Texts.Writer;
  52.         id: Name;
  53.         lineBeg: LONGINT;
  54.         lastID: Name;
  55.         lastIDline: LONGINT;
  56.         type: Name;
  57.         classes: Class;
  58. (* scanner *)
  59.     PROCEDURE Ch;
  60.     BEGIN
  61.         Texts.Read(R, ch); INC(pos)
  62.     END Ch;
  63.     PROCEDURE Start(n: LONGINT);
  64.     BEGIN
  65.         pos := n; Texts.OpenReader(R, TMod, pos)
  66.     END Start;
  67.     PROCEDURE Comment;
  68.     BEGIN
  69.         LOOP
  70.             IF R.eot THEN RETURN
  71.             ELSIF ch = "*" THEN Ch; IF ch = ")" THEN Ch; RETURN END
  72.             ELSIF ch = "(" THEN Ch; IF ch = "*" THEN Ch; Comment END
  73.             ELSE Ch
  74.             END
  75.         END
  76.     END Comment;
  77.     PROCEDURE Ident;
  78.         VAR i: INTEGER;
  79.     BEGIN sym := ident; i := 0;
  80.         REPEAT id[i] := ch; Ch; INC(i) UNTIL (ch < "0") & (ch # ".") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z");
  81.         id[i] := 0X
  82.     END Ident;
  83.     PROCEDURE Sym;
  84.         VAR ch0: CHAR;
  85.     BEGIN
  86.         lastSym := sym; lastPos := pos; sym := none;
  87.         WHILE sym = none DO
  88.             CASE ch OF
  89.             |  0X: sym := eot
  90.             |  1X.." ": REPEAT IF ch = CR THEN lineBeg := pos END; Ch UNTIL (ch > " ") OR (ch = 0X)
  91.             |  "a".."z", "A".."Z": Ident;
  92.                     CASE id[0] OF
  93.                     | "A": IF id = "ARRAY" THEN sym := array END
  94.                     | "E": IF id = "END" THEN sym := end END
  95.                     | "P": IF id = "PROCEDURE" THEN sym := procedure ELSIF id = "POINTER" THEN sym := pointer END
  96.                     | "R": IF id = "RECORD" THEN sym := record END
  97.                     ELSE
  98.                     END;
  99.                     IF sym = ident THEN lastID := id; lastIDline := lineBeg END
  100.             |  "'", '"': ch0 := ch; REPEAT Ch UNTIL (ch = ch0) OR (ch < " ") OR R.eot; Ch
  101.             |  "(": Ch; IF ch = "*" THEN Ch; Comment ELSE sym := lparen END
  102.             |  ")": sym := rparen; Ch
  103.             |  ":": sym := colon; Ch
  104.             | "=": sym := eql; Ch
  105.             |  ";": sym := semicolon; Ch
  106.             | "^": sym := arrow; Ch
  107.             | "*": sym := star; Ch
  108.             ELSE Ch
  109.             END
  110.         END
  111.     END Sym;
  112. (* parser *)
  113.     PROCEDURE FindClass(VAR id: Name; VAR c: Class);
  114.     BEGIN c := classes;
  115.         WHILE (c # NIL) & (c.name # id) DO c := c.next END
  116.     END FindClass;
  117.     PROCEDURE FindLink(VAR id: Name; VAR c: Class);
  118.         VAR p: Class;
  119.     BEGIN p := classes;
  120.         WHILE (p # NIL) & ((p.link = NIL) OR (p.link.name # id)) DO p := p.next END;
  121.         IF p = NIL THEN c := NIL ELSE c := p.link END
  122.     END FindLink;
  123.     PROCEDURE RecordType(VAR c: Class);
  124.         VAR ok: BOOLEAN; c0: Class;
  125.     BEGIN c := NIL;
  126.         ok := lastSym IN {eql, ident};
  127.         IF lastSym = eql THEN FindLink(lastID, c) END;
  128.         IF c = NIL THEN NEW(c); c.name := lastID; c.kind := record END;
  129.         c.beg := lastIDline;
  130.         LOOP Sym;
  131.             IF sym IN {end, eot} THEN c.end := lastPos - 1; EXIT
  132.             ELSIF sym = record THEN RecordType(c0) (*ignore nested records*)
  133.             END
  134.         END;
  135.         IF ~ok THEN c := NIL END
  136.     END RecordType;
  137.     PROCEDURE PointerType(VAR c: Class);
  138.         VAR ok: BOOLEAN; c0: Class;
  139.     BEGIN
  140.         ok := lastSym = eql;
  141.         NEW(c); c.name := lastID; c.kind := pointer; c.beg := lastIDline;
  142.         Sym; Sym;
  143.         IF sym = ident THEN
  144.             FindClass(id, c0);
  145.             IF c0 = NIL THEN NEW(c0); c0.name := id; c0.kind := record END;
  146.             c.link := c0; Sym; c.end := pos - 1;
  147.         ELSIF sym = record THEN
  148.             RecordType(c0); c.link := c0; c0.name := "";
  149.             c.end := lastPos - 1;
  150.             IF ok THEN c0.next := classes; classes := c0 END
  151.         ELSE ok := FALSE
  152.         END;
  153.         IF ~ok THEN c := NIL END
  154.     END PointerType;
  155.     PROCEDURE Procedure;
  156.         VAR m: Method; className: Name; c: Class;
  157.     BEGIN 
  158.         NEW(m); m.beg := pos-10;
  159.         Sym; IF sym # lparen THEN RETURN END;
  160.         REPEAT Sym UNTIL sym IN {colon, eot};
  161.         Sym; className := id;
  162.         REPEAT Sym UNTIL sym IN {lparen, semicolon, eot};
  163.         IF sym = lparen THEN REPEAT Sym UNTIL sym IN {rparen, eot};
  164.             Sym; IF sym = colon THEN Sym; Sym END
  165.         END;
  166.         m.end := pos - 1;
  167.         FindClass(className, c); IF c = NIL THEN RETURN END;
  168.         IF c.kind = pointer THEN c := c.link END;
  169.         m.next := c.methods; c.methods := m
  170.     END Procedure;
  171. (* output routines *)
  172.     PROCEDURE Wr(ch: CHAR);
  173.     BEGIN Texts.Write(W, ch)
  174.     END Wr;
  175.     PROCEDURE Str(s: ARRAY OF CHAR);
  176.     BEGIN Texts.WriteString(W, s)
  177.     END Str;
  178.     PROCEDURE Lead(pos: LONGINT): INTEGER;
  179.         VAR n: INTEGER;
  180.     BEGIN Start(pos); n := -1;
  181.         REPEAT Ch; INC(n) UNTIL (ch > " ") OR (ch = CR) OR R.eot;
  182.         RETURN n
  183.     END Lead;
  184.     PROCEDURE OutStretch(from, to: LONGINT; VAR ind, nLines: INTEGER; VAR leadCh: CHAR);
  185.         VAR lead, i: INTEGER; pos: LONGINT;
  186.     BEGIN
  187.         lead := Lead(from); nLines := 0;
  188.         REPEAT
  189.             ind := Lead(from) - lead; INC(nLines);
  190.             Start(from); FOR i := 1 TO lead DO Ch; INC(from) END;
  191.             IF ch = " " THEN leadCh := " " ELSE leadCh := TAB END;
  192.             pos := from;
  193.             WHILE (from < to) & (ch # CR) DO Ch; INC(from) END;
  194.             Texts.Append(TOut, W.buf);
  195.             Texts.Save(TMod, pos, from, B); Texts.Append(TOut, B)
  196.         UNTIL from >= to;
  197.     END OutStretch;
  198.     PROCEDURE OutMethod(m: Method; ind: INTEGER; leadCh: CHAR);
  199.         VAR i, j: INTEGER; k: CHAR;
  200.     BEGIN
  201.         IF m # NIL THEN OutMethod(m.next, ind, leadCh);
  202.             FOR i := 1 TO ind DO Wr(leadCh) END;
  203.             OutStretch(m.beg, m.end, i, j, k); Wr(CR)
  204.         END;
  205.     END OutMethod;
  206.     PROCEDURE OutClass(c: Class);
  207.         VAR ind, nLines, i: INTEGER; leadCh: CHAR;
  208.     BEGIN
  209.         OutStretch(c.beg, c.end, ind, nLines, leadCh); Wr(CR);
  210.         IF nLines = 1 THEN INC(ind) END; 
  211.         IF (c.kind = pointer) & (c.link # NIL) THEN
  212.             IF c.link.name = "" THEN c := c.link ELSIF type # "" THEN OutClass(c.link); RETURN END
  213.         END;
  214.         IF c.kind = record THEN
  215.             OutMethod(c.methods, ind, leadCh);
  216.             Str("END;"); Wr(CR)
  217.         END
  218.     END OutClass;
  219.     PROCEDURE OutAll(c: Class);
  220.     BEGIN
  221.         IF c # NIL THEN OutAll(c.next);
  222.             IF c.name # "" THEN OutClass(c) END
  223.         END
  224.     END OutAll;
  225. (* main *)
  226.     PROCEDURE PrepName(s: ARRAY OF CHAR; VAR mod, type: ARRAY OF CHAR);
  227.         VAR i, j: INTEGER;
  228.     BEGIN i := 0;
  229.         REPEAT mod[i] := s[i]; INC(i) UNTIL (s[i-1] = 0X) OR (s[i-1] = ".");
  230.         IF s[i-1] = "." THEN mod[i] := "M"; mod[i+1] := "o"; mod[i+2] := "d"; mod[i+3] := 0X;
  231.             j := 0; REPEAT type[j] := s[i]; INC(i); INC(j) UNTIL s[i-1] = 0X
  232.         ELSE COPY(mod, type); mod[0] := 0X
  233.         END
  234.     END PrepName;
  235.     PROCEDURE Show*;    (** ( "*" | "^" | name ) **)
  236.         VAR S: Texts.Scanner; V: Viewers.Viewer; text: Texts.Text; Menu, Text: TextFrames.Frame; x, y: INTEGER;
  237.             selbeg, selend, time: LONGINT; c: Class; m: Method; mod: Name;
  238.     BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
  239.         IF (S.class = Texts.Char) & (S.c = "*") & (S.line = 0) THEN V := Oberon.MarkedViewer();
  240.             IF (V # NIL) & (V.dsc # NIL) & (V.dsc.next # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
  241.                 TMod := V.dsc.next(TextFrames.Frame).text; type := ""
  242.             ELSE RETURN
  243.             END
  244.         ELSIF (S.class = Texts.Name) & (S.line = 0) THEN
  245.             PrepName(S.s, mod, type); TMod := TextFrames.Text(mod)
  246.         ELSE Oberon.GetSelection(text, selbeg, selend, time);
  247.             IF time > 0 THEN Texts.OpenScanner(S, text, selbeg); Texts.Scan(S);
  248.                 IF (S.class # Texts.Name) OR (S.line > 0) THEN RETURN END
  249.             ELSE RETURN
  250.             END;
  251.             PrepName(S.s, mod, type);
  252.             IF mod = "" THEN TMod := text ELSE TMod := TextFrames.Text(mod) END
  253.         END;
  254.         Start(0); Ch; sym := none; lineBeg := 0; lastID := ""; lastIDline := 0; lastSym := none; classes := NIL;
  255.         LOOP Sym;
  256.             CASE sym OF
  257.                 procedure: Procedure
  258.             | record: RecordType(c); IF c # NIL THEN c.next := classes; classes := c END
  259.             | pointer: PointerType(c); IF c # NIL THEN c.next := classes; classes := c END
  260.             | eot: EXIT
  261.             ELSE
  262.             END
  263.         END;
  264.         TOut := TextFrames.Text(""); NEW(B); Texts.OpenBuf(B);
  265.         Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  266.         IF type = "" THEN OutAll(classes)
  267.         ELSE FindClass(type, c); IF c # NIL THEN OutClass(c) END
  268.         END;
  269.         Texts.Append(TOut, W.buf);
  270.         V := MenuViewers.New(TextFrames.NewMenu(type, StdMenu), TextFrames.NewText(TOut, 0),
  271.             TextFrames.menuH, x, y);
  272.         TMod := NIL; TOut := NIL; B := NIL; classes := NIL
  273.     END Show;
  274. BEGIN Texts.OpenWriter(W)
  275. END Class.
  276.